home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
PROGS
/
TP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-05-03
|
19KB
|
616 lines
PROGRAM TP;
{$M 20000,0,25000}
Uses DOS, CRT, PbCRT, PbMISC, PbDATA, PbPARMS;
{
Description : Turbo Development shell
Author : Howard Richoux
Date : 12/19/93
Last revised: 12/21/93 hnr minor fixes Works well!
12/22/93 1.14 hnr cleaned up CLEANUP
12/23/93 1.15 hnr added DOC and CFG cmds
12/24/93 1.16 hnr added Find cmd
2/13/93 1.20 hnr added PLAY, RELEASE=, MAINONLY=
2/13/93 1.21 hnr added BACKUP and PUT
*** need switchable tp.cfg ***
2/17/94 1.25 hnr added COMPILER=
2/18/94 1.26 hnr new libraries
Application : IBM PC and compatibles, done in Turbo Pascal 7.0
Status : Placed in the Public Domain by HNR Software 1/29/94
Published in: none
Parameters Use Default
PROMPT=xxxx CRT prompt string '*'
MAIN=<fname> main Pascal program ''
FILE1=<fname> support unit ''
...
FILE5=<fname> support unit ''
EDITOR=<exename> designates edit program '\hnrutil\ted.exe'
COMPILER=<exename> designates compiler program '\bp\bin\tpc.exe'
COMPswitch=xxx compiler switch option ''
PROGPATH=<dir> where to get 'main' '\hnrprog'
UNITPATH=<dir> where to get 'filen' '\hnrstuf'
EXEPATH=<dir> where to put exe '\hnrutil'
}
const debug = 0;
var outfile : string;
maincolor : integer;
statuscolor : integer;
var prompt : string[20];
const files_max = 5;
type files_array = array[1..files_max] of string[8];
var main : string[8];
files : files_array;
progpath : string[60];
unitpath : string[60];
exepath : string[60];
tpcfgpath : string[60];
logfile : string[60];
editor : string[60];
compiler : string[60];
compswitch: string[60];
cfgfile : string[60];
var InputType : integer;
mapflag : boolean;
UnitsOnlyFlag : boolean; { for test-type programs - no release }
MainOnlyFlag : boolean; { for Utility programs where units were used for testin}
ReleaseFlag : boolean; { overall control }
const typInputCRT = 1;
const typInputFIL = 2;
{*****************************************************************}
Procedure WorkWindowx;
begin
CRT.window(1,1,80,22);
gotoxy(1,22);
end;
Procedure StatusWindowx;
begin
CRT.gotoxy(1,22);
writeln('');
writeln('');
CRT.window(1,23,80,24);
gotoxy(1,22);
end;
Function HiLite(fname : string; ln : integer):string;
var fn,s : string;
begin
s := fname;
fn := fname;
forceext(fn,'pas');
if fileexists(fn) then
begin
s := leftstr(UpCaseStr(fname),ln);
if filedate(fname,'tpu') > filedate(fname,'pas') then
s := '*' + s;
end
else s := leftstr(DnCaseStr(fname),ln);
HiLite := s;
end;
Procedure UpdateStatusLine;
var x,y,i : integer;
begin
x := wherex; y := wherey;
if y > 22 then for i := 23 to y do writeln('');
CRT.TextColor(statuscolor);
gotoxy(1,24);write(conststr(' ',79));
gotoxy(1,25);
write(pProgID,': ',HiLite(MAIN,8));
for i := 1 to files_max do
begin
write(' ',i:1,'-',HiLite(files[i],8));
end;
CRT.clreol;
gotoxy(1,23);
CRT.TextColor(maincolor);
end;
Procedure ClearStatusLine;
var x,y,i : integer;
begin
x := wherex; y := wherey;
gotoxy(1,25);write(conststr(' ',79));
gotoxy(1,24);
gotoxy(1,23);
end;
Procedure ExecCmd(s : string); {[MISC] ExecuteCommand too long }
begin
writeln(s);
ExecuteCommand(s);
end;
Function DecodeFN(s : string) : string;
var i : integer;
begin
DecodeFN := '';
if length(s) = 1 then DecodeFN := main
else begin
for i := 1 to files_max do
begin
if s[2] = integerstr(i,1) then DecodeFN := files[i];
end;
end;
end;
Procedure ShowSettings;
begin
writeln('TP MAIN: ',main);
writeln(' ProgPath: ',leftstr(progpath,30));
writeln(' UnitPath: ',leftstr(unitpath,30));
writeln('');
end;
Procedure CopyfileIfNecessary(fn1,fn2 : string);
var ok : boolean;
begin
ok := true;
if not fileexists(fn1) then exit;
if not EquivalentFile(fn1,fn2) then
begin
if fileexists(fn2) and (filedate(fn2,'') > filedate(fn1,'')) then
begin
writeln(FmtFileInfo(fn1,''));
writeln(FmtFileInfo(fn2,''));
ok := CheckYesNo(fn2+' is NEWER - replace? ','n');
if ok then ok := CheckYesNo('Are you SURE? ','n');
end;
{ writeln('COPYING '+fn1+' '+fn2);}
if ok then ExecCmd('copy '+fn1+' '+fn2);
end;
end;
Procedure DoBAT(fname : string);
var fn : string;
begin
if fname = '' then exit;
fn := fname;
forceext(fn,'bat');
if fileexists(fn) then
ExecCmd(fn)
else writeln('Batch file does not exist [',fn,']');
end;
Procedure DoGetFile(s,ext : string);
var fn,fn1 : string;
begin
fn := DecodeFN(s);
if fn = '' then exit;
ForceExt(fn,ext);
if length(s) = 1 then
fn1 := addbackslash(progpath)+fn
else fn1 := addbackslash(unitpath)+fn;
CopyFileIfNecessary(fn1,fn);
end;
Procedure DoFindFiles(s,ext : string);
var fn,fn1 : string;
begin
fn := DecodeFN(s);
if fn = '' then exit;
ForceExt(fn,ext);
ExecCmd('find '+fn);
end;
Procedure DoEditor(s,ext : string);
var fn : string;
begin
if leftstr(s,3) = 'TED' then
begin
fn := s;
delete(fn,1,4);
end
else if leftstr(s,4) = 'EDIT' then
begin
fn := s;
delete(fn,1,5);
end
else fn := DecodeFN(s);
if fn = '' then
begin
writeln('No file specified. [',s,']');
exit;
end;
if ext <> '' then ForceExt(fn,ext);
ExecCmd(Editor+' '+fn);
end;
Procedure DoPrintFile(str,ext : string;intflag : boolean);
var fn,s : string;
begin
s := '';
fn := DecodeFN(str);
writeln(s,' [',fn,']');
if fn = '' then exit;
if intflag then
begin
s := ' INTERFACE=YES';
if length(s) = 1 then
begin
writeln('Unable to print Interface ONLY on a Program - ',fn);
exit;
end;
end;
if ext <> '' then ForceExt(fn,ext);
ExecCmd('TLISTER '+fn+s);
end;
Procedure DoCompile(s,ext : string);
var fn : string;
begin
fn := DecodeFN(s);
if fn = '' then exit;
forceext(fn,'tpu');
erasefile(fn);
forceext(fn,'tpp');
erasefile(fn);
forceext(fn,'exe');
erasefile(fn);
forceext(fn,'pas');
if fileexists(fn) then
begin
if mapflag then ExecCmd(compiler+' '+compswitch+' /GP '+fn)
else ExecCmd(compiler+' '+compswitch+' '+fn);
end;
end;
Procedure CleanUpOneFile(root,ext,destpath,prompt : string;var moved : boolean);
{ Returns file to master library if changed }
var fn1,fn2 : string;
ok : boolean;
begin
moved := false;
{ fn1 Master copy, fn2 New work }
fn1 := root; forceext(fn1,ext); fn1 := addbackslash(destpath)+fn1; {MASTER}
fn2 := root; forceext(fn2,ext); {NEW file}
if filedate(fn2,'') > filedate(fn1,'') then
begin
ok := CheckYesNo('Need to update MASTER -'+prompt+'- File: '+
fn1+' OK?','N');
CopyFileIfNecessary(fn2,fn1);
if EquivalentFile(fn1,fn2) then {makes sure copy went OK}
begin
moved := true;
writeln('Erasing ',fn2);
EraseFile(fn2);
end;
end
else begin { no updating needed }
if fileexists(fn2) then writeln('Erasing ',fn2);
EraseFile(fn2);
end;
end;
Procedure CleanUpFiles;
{ Done on Completion }
var s,cmd,fn1,fn2 : string;
var i : integer;
ok,moved : boolean;
begin
if not releaseflag then
begin
writeln('RELEASE is set to NO, Files will NOT be moved.');
ExecCmd('Erase *.bak');
ExecCmd('DDIR');
exit;
end;
if not unitsonlyflag then
begin
CleanUpOneFile(main,'pas',progpath,'MAIN Source',moved);
CleanUpOneFile(main,'exe',exepath, 'MAIN EXE',moved);
CleanUpOneFile(main,'doc',progpath,'Documentation',moved);
if moved then { Copy the Master DOC file to the EXE path }
begin
fn1 := main; forceext(fn1,'doc');
fn2 := main; forceext(fn2,'doc');
fn1 := addbackslash(exepath)+fn1; {fn1 - exe path }
fn2 := addbackslash(progpath)+fn2; {fn2 - MASTER}
CopyFileIfNecessary(fn2,fn1);
end;
end
else begin
writeln('UNITSONLY=YES, MAIN not moved.');
end;
if not mainonlyflag then
begin
{ SUPPORT UNITS - fn1 Old Master copy, fn2 New work }
for i := 1 to files_max do
begin
if files[i] <> '' then
begin
CleanUpOneFile(files[i],'pas',unitpath,'UNIT Source',moved);
fn2 := files[i]; forceext(fn2,'pas');
if moved then
begin
writeln('*** Remember to RE-BUILD UNIT Library (MAKEPUB) ***');
end;
fn2 := files[i]; forceext(fn2,'tpu'); {local TPU file}
forceext(fn2,'tpu'); { erasing TPU file }
if fileexists(fn2) then
begin
writeln('Erasing ',fn2);
EraseFile(fn2);
end;
forceext(fn2,'tpp'); { erasing TPP file }
if fileexists(fn2) then
begin
writeln('Erasing ',fn2);
EraseFile(fn2);
end;
end;
end;
end
else begin
writeln('MAINONLY=YES, UNITS not moved.');
end;
ExecCmd('Erase *.bak');
ExecCmd('DDIR');
end;
{PAGE}
Procedure GetCRTInput(prompt : string; var s,cmd : string);
begin
write(prompt);CRT.Clreol;
GetKeyInput(s,cmd);
writeln('');
end;
Procedure ProcessInput(var str,cmd : string);
var s,s1 : string;
begin
s := UpCaseStr(str);
if (debug>0) then writeln(' str=[',s,'] cmd[',cmd,']');
writeln('');
if s = 'CFG' then DoEditor(main,'cfg')
else if s = 'BACKUP' then begin
ExecCmd('ZIP'); {copy/pack this DIR}
GetDir(0,s1);
s1 := dirtag(s1);
ExecCmd('PUT '+s1); {Backup to floppy}
end
else if s = 'CLEANUP' then CleanUpFiles
else if s = 'DIR' then ExecCmd('ddir')
else if leftstr(s,3) = 'TED' then DoEditor(s,'')
else if leftstr(s,4) = 'EDIT' then DoEditor(s,'')
else if s = 'C' then begin { fix this later }
DoCompile('C5','pas');
DoCompile('C4','pas');
DoCompile('C3','pas');
DoCompile('C2','pas');
DoCompile('C1','pas');
DoCompile('C','pas');
end
else if s = 'CLS' then begin
CRT.clrscr;
gotoxy(1,3);
end
else if s = 'CFG' then DoEditor('E','CFG')
else if s = 'DOC' then DoEditor('E','DOC')
else if s = 'HELP' then ShowDOCFile
else if s = 'G' then begin
if not unitsonlyflag then
begin
DoGetFile('G','pas');
DoGetFile('G','doc');
end;
DoGetFile('G1','pas');
DoGetFile('G2','pas');
DoGetFile('G3','pas');
DoGetFile('G4','pas');
DoGetFile('G5','pas');
end
else if s = 'L' then ShowSettings
else if s = 'MAP' then EXECCmd('TMAP *.map 3 p')
else if s = 'MAPON' then mapflag := true
else if s = 'MAPOFF' then begin
mapflag := false;
ExecCmd('Erase *.map');
end
else if s = 'PLAY' then ExecCmd('PLAY') {Play a CD}
else if s = 'PUT' then begin
ExecCmd('PUT'); {Backup to floppy}
end
else if s = 'Q' then cmd := '?EXIT'
else if s = 'T' then DoBAT('T.BAT')
else if s = 'T1' then DoBAT('T1.BAT')
else if s = 'T2' then DoBAT('T2.BAT')
else if s = 'T3' then DoBAT('T3.BAT')
else if s = 'T4' then DoBAT('T4.BAT')
else if s = 'T5' then DoBAT('T5.BAT')
else if s = 'X' then cmd := '?EXIT'
else if s = 'ZIP' then ExecCmd('ZIP')
else if s[1] = 'C' then DoCompile(s,'pas')
else if s[1] = 'E' then DoEditor(s,'pas')
else if s[1] = 'F' then DoFindFiles(s,'pas')
else if s[1] = 'G' then DoGetFile(s,'pas')
else if s[1] = 'I' then DoPrintFile(s,'pas',true)
else if s[1] = 'P' then DoPrintFile(s,'pas',false)
else begin
writeln('');
writeln('? [',str,']');
end;
end;
Procedure MainInputLoop;
var str,cmd : string;
var i : integer;
begin
writeln('');
UpdateStatusLine;
i := 0; str := ''; cmd := '?STRING';
while (cmd <> '?EXIT') and (cmd <> '?ESCAPE') do
begin
UpdateStatusLine;
case InputType of
typInputCRT : GetCRTInput(prompt,str,cmd);
else begin
writeln('MAIN Input loop - bad input type [',
InputType,']');
cmd := '?ESCAPE';
end;
end;
writeln('');
ClearStatusLine;
if cmd = '?FKEY1' then ShowDOCFile
else if cmd = '?FKEY10' then cmd := '?EXIT'
else ProcessInput(str,cmd);
{inc(i); if i > 500 then cmd := '?ESCAPE';} {safety valve}
end;
end;
Procedure PrepareFiles;
{ Done on Startup }
var s,cmd,fn1,fn2 : string;
var i : integer;
begin
fn1 := main; forceext(fn1,'pas'); fn1 := addbackslash(progpath)+fn1;
fn2 := main; forceext(fn2,'pas');
CopyfileIfNecessary(fn1,fn2);
for i := 1 to files_max do
begin
if files[i] <> '' then
begin
fn1 := files[i];
forceext(fn1,'pas');
fn1 := addbackslash(unitpath)+fn1;
fn2 := files[i];
forceext(fn2,'pas');
CopyfileIfNecessary(fn1,fn2);
end;
end;
cmd := '';
s := 'DIR'; ProcessInput(s,cmd);
end;
Procedure GetCFGFile;
var s,fn : string;
begin
tpcfgpath := '';
s := '';
if paramcount > 0 then s := paramstr(1);
if s[1] = '@' then
begin
delete(s,1,1);
fn := s;
if fileexists(fn) then
begin
copyfileifnecessary(fn,'tp.cfg');
end;
end;
end;
Procedure Init;
var s : string;
begin
InputType := typInputCRT;
AddParm(1,'MAIN','');
AddParm(1,'FILE1','');
AddParm(1,'FILE2','');
AddParm(1,'FILE3','');
AddParm(1,'FILE4','');
AddParm(1,'FILE5','');
AddParm(1,'EDITOR','C:\UTIL\TED.EXE');
AddParm(1,'COMPILER','C:\BP\BIN\TPC.EXE');
AddParm(1,'COMPSWITCH','');
AddParm(1,'PROGPATH','C:\HNRPROG\');
AddParm(1,'UNITPATH','C:\HNRSTUF\');
AddParm(1,'EXEPATH','C:\HNRUTIL\');
AddParm(1,'LOGFILE','\HNRUTIL\TP.LOG');
AddParm(1,'MAP','NO');
AddParm(1,'RELEASE','NO');
AddParm(1,'UNITSONLY','NO');
AddParm(1,'MAINONLY','NO');
StandardPvarsInit;
main := GetParmStr('MAIN');
if files_max >= 1 then files[1] := GetParmStr('FILE1');
if files_max >= 2 then files[2] := GetParmStr('FILE2');
if files_max >= 3 then files[3] := GetParmStr('FILE3');
if files_max >= 4 then files[4] := GetParmStr('FILE4');
if files_max >= 5 then files[5] := GetParmStr('FILE5');
editor := GetParmStr('EDITOR');
compiler := GetParmStr('COMPILER');
compswitch := GetParmStr('COMPSWITCH');
progpath := GetParmStr('PROGPATH');
unitpath := GetParmStr('UNITPATH');
exepath := GetParmStr('EXEPATH');
logfile := GetParmStr('LOGFILE');
mapflag := CheckOK('MAP');
releaseflag := CheckOK('RELEASE');
unitsonlyflag := CheckOK('UNITSONLY');
mainonlyflag := CheckOK('MAINONLY');
prompt := 'TP>';
end;
(* Main program *)
BEGIN
maincolor := lightgray;
statuscolor := yellow;
CRT.TextColor(maincolor);
pProgID := 'TP 1.26';
cfgfile := FileRootStr(paramstr(0)) + '.cfg';
if UpCaseStr(paramstr(1)) = 'HELP' then ShowDocFile
else if (not fileExists(cfgfile)) or (paramcount > 0) then
begin
GetCFGFile;
Init;
if main <> '' then PrepareFiles
else writeln('No MAIN file specified');
end
else begin
Init;
if main <> '' then MainInputLoop
else writeln('No MAIN file specified');
end;
CRT.TextColor(maincolor);
end.